Linux Cubed Series 3: Developer Tools/Linux Cubed Series 3 - Developer Tools.iso/devel/lang/lisp/guile-ii.src/guile-ii/guile-src/gls/Ginit.scm

Text File | 1995-08-17 | 35.6 KB | 1,302 lines

;;;;     copyright (C) 1995 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;;;


;;; Parts of this file derived from
;;;     "Init.scm", Scheme initialization code for SCM.
;;;     Copyright (C) 1991, 1992, 1993, 1994 Aubrey Jaffer.
;;;

(define (scheme-implementation-type) 'GUILE)
(define (scheme-implementation-version) 'iii)


(define < <?)
(define <= <=?)
(define = =?)
(define > >?)
(define >= >=?)



;;; {Features}
;;;
;;; Features are named options which may or may not be present
;;; in an interpreter.  They can be tested for either by code or
;;; by conditional forms (e.g. "#- hash (load-slib-hash)" )
;;;

(set! *features*
      (append '(getenv tmpnam abort transcript with-file
        ieee-p1178 rev4-report rev4-optional-procedures
        hash hash-table object-hash delay eval dynamic-wind
        multiarg-apply multiarg/and- logical defmacro
        string-port source current-time)
          *features*))


;; Evaluate a boolean expression whose terms are feature names.
;;
(define (read:eval-feature exp)
  (cond ((symbol? exp)
     (or (memq exp *features*) (eq? exp (software-type))))
    ((and (pair? exp) (list? exp))
     (case (car exp)
       ((not) (not (read:eval-feature (cadr exp))))
       ((or) (if (null? (cdr exp)) #f
             (or (read:eval-feature (cadr exp))
             (read:eval-feature (cons 'or (cddr exp))))))
       ((and) (if (null? (cdr exp)) #t
              (and (read:eval-feature (cadr exp))
               (read:eval-feature (cons 'and (cddr exp))))))
       (else (error "read:sharp+ invalid expression " exp))))))


;;; {Reader Extensions}
;;;
;;; Reader code for various "#c" forms.
;;;


(define (read:sharp c port)
  (define (barf)
    (error "unknown # object" c))
  (case c ((#\') (read port))
    ((#\+) (if (read:eval-feature (read port))
           (read port)
           (begin (read port) (if #f #f))))
    ((#\-) (if (not (read:eval-feature (read port)))
           (read port)
           (begin (read port) (if #f #f))))
    ((#\b) (read:uniform-vector #t port))
    ((#\a) (read:uniform-vector #\a port))
    ((#\u) (read:uniform-vector 1 port))
    ((#\e) (read:uniform-vector -1 port))
    ((#\s) (read:uniform-vector 1.0 port))
    ((#\i) (read:uniform-vector 1/3 port))
    ((#\c) (read:uniform-vector 0+i port))
    ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
     (read:array c port))
    ((#\!) (if (= 1 (line-number))
           (let skip () (if (eq? #\newline (peek-char port))
                    (if #f #f)
                    (begin (read-char port) (skip))))
           (barf)))
    (else (barf))))

(define (read:array digit port)
  (define chr0 (char->integer #\0))
  (let ((rank (let readnum ((val (- (char->integer digit) chr0)))
        (if (char-numeric? (peek-char port))
            (readnum (+ (* 10 val)
                (- (char->integer (read-char port)) chr0)))
            val)))
    (prot (if (eq? #\( (peek-char port))
          '()
          (let ((c (read-char port)))
            (case c ((#\b) #t)
              ((#\a) #\a)
              ((#\u) 1)
              ((#\e) -1)
              ((#\s) 1.0)
              ((#\i) 1/3)
              ((#\c) 0+i)
              (else (error "read:array unknown option " c)))))))
    (if (eq? (peek-char port) #\()
    (list->uniform-array rank prot (read port))
    (error "read:array list not found"))))

(define (read:uniform-vector proto port)
  (if (eq? #\( (peek-char port))
      (list->uniform-array 1 proto (read port))
      (error "read:uniform-vector list not found")))


;;; {Here are Some Revised^2 Scheme Functions}
;;;

(define 1+
  (let ((+ +))
    (lambda (n) (+ n 1))))

(define -1+
  (let ((+ +))
    (lambda (n) (+ n -1))))


(define 1- -1+)
(define t #t)
(define nil #f)
(define sequence begin)

(set! apply (lambda (fun . args) (@apply fun (apply:nconc2last args))))

(define (call-with-current-continuation proc)
  (@call-with-current-continuation proc))



;;; {Slib-ish Names for Bit-twiddling Functions}
;;;

(define logical:logand logand)
(define logical:logior logior)
(define logical:logxor logxor)
(define logical:lognot lognot)
(define logical:ash ash)
(define logical:logcount logcount)
(define logical:integer-length integer-length)
(define logical:bit-extract bit-extract)
(define logical:integer-expt integer-expt)

(define (logical:ipow-by-squaring x k acc proc)
  (cond ((zero? k) acc)
    ((= 1 k) (proc acc x))
    (else (logical:ipow-by-squaring (proc x x)
                    (quotient k 2)
                    (if (even? k) acc (proc acc x))
                    proc))))



;;; {Basic Port Code}
;;;
;;; Specificly, the parts of the low-level port code that are written in
;;; Scheme rather than C.
;;;

;; VMS does something strange when output is sent to both
;; CURRENT-OUTPUT-PORT and CURRENT-ERROR-PORT.
(case (software-type)
  ((VMS) (set-current-error-port (current-output-port))))

;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the proper
;; mode to open files in.  MSDOS does carraige return - newline
;; translation if not opened in `b' mode.
;;
(define OPEN_READ (case (software-type)
            ((MS-DOS WINDOWS ATARIST) "rb")
            (else "r")))
(define OPEN_WRITE (case (software-type)
             ((MS-DOS WINDOWS ATARIST) "wb")
             (else "w")))
(define OPEN_BOTH (case (software-type)
            ((MS-DOS WINDOWS ATARIST) "r+b")
            (else "r+")))


(define (open-input-file str)
  (or (open-file str OPEN_READ)
      (error "OPEN-INPUT-FILE couldn't find file " str)))

(define (open-output-file str)
  (or (open-file str OPEN_WRITE)
      (error "OPEN-OUTPUT-FILE couldn't find file " str)))

(define (open-io-file str) (open-file str OPEN_BOTH))
(define close-input-port close-port)
(define close-output-port close-port)
(define close-io-port close-port)

(define (call-with-input-file str proc)
  (let* ((file (open-input-file str))
     (ans (proc file)))
    (close-input-port file)
    ans))

(define (call-with-output-file str proc)
  (let* ((file (open-output-file str))
     (ans (proc file)))
    (close-output-port file)
    ans))

(define (with-input-from-port port thunk)
  (let* ((swaports (lambda () (set! port (set-current-input-port port)))))
    (dynamic-wind swaports thunk swaports)))

(define (with-output-to-port port thunk)
  (let* ((swaports (lambda () (set! port (set-current-output-port port)))))
    (dynamic-wind swaports thunk swaports)))

(define (with-error-to-port port thunk)
  (let* ((swaports (lambda () (set! port (set-current-error-port port)))))
    (dynamic-wind swaports thunk swaports)))

(define (with-input-from-file file thunk)
  (let* ((nport (open-input-file file))
     (ans (with-input-from-port nport thunk)))
    (close-port nport)
    ans))

(define (with-output-to-file file thunk)
  (let* ((nport (open-output-file file))
     (ans (with-output-to-port nport thunk)))
    (close-port nport)
    ans))

(define (with-error-to-file file thunk)
  (let* ((nport (open-output-file file))
     (ans (with-error-to-port nport thunk)))
    (close-port nport)
    ans))


(if (not (defined? output-port-width))
    (define (output-port-width . arg) 80))

(if (not (defined? output-port-height))
    (define (output-port-height . arg) 24))

(define (with-input-from-string string thunk)
  (call-with-input-string string
   (lambda (p) (with-input-from-port p thunk))))

(define (with-output-to-string thunk)
  (call-with-input-string
   (lambda (p) (with-output-to-port p thunk))))

(define (with-error-to-string thunk)
  (call-with-input-string
   (lambda (p) (with-error-to-port p thunk))))



;;; {Symbol Properties}
;;;

(define (symbol-property sym prop)
  (let ((pair (assoc prop (symbol-pref sym))))
    (and pair (cdr pair))))

(define (set-symbol-property! sym prop val)
  (let ((pair (assoc prop (symbol-pref sym))))
    (if pair
    (set-cdr! pair val)
    (symbol-pset! sym (acons prop val (symbol-pref sym))))))

(define (set-symbol-property! sym prop val)
  (let ((pair (assoc prop (symbol-pref sym))))
    (if pair
    (set-cdr! pair val)
    (symbol-pset! sym (acons prop val (symbol-pref sym))))))

(define (symbol-property-remove! sym prop)
  (let ((pair (assoc prop (symbol-pref sym))))
    (if pair
    (symbol-pset! sym (delq! pair (symbol-pref sym))))))


;;; {Error Handling}
;;;


;; %%bad-throw is the hook that is called upon a throw to a an unhandled
;; key.  If the key has a default handler (a throw-handler-default property),
;; it is applied to the throw.
;;
(define (%%bad-throw key . args)
  (let ((default (and (symbol? key)
              (symbol-property key 'throw-handler-default))))
    (and default (apply default key args))))

;; (error . args) is short for (throw (quote error) . args)
;;
(define (error . args)
  (apply throw 'error args))

;; Error handling a la SCM.
;;
(define (%%default-error-handler ignored . args)
  (define cep (current-error-port))
  (perror "ERROR")
  (errno 0)
  (display "ERROR: " cep)
  (if (not (null? args))
      (begin (display (car args) cep)
         (for-each (lambda (x) (display #\  cep) (write x cep))
               (cdr args))))
  (newline cep)
  (force-output cep)
  (abort))


;; Install SCM error handling as the default.
;;
(set-symbol-property! 'error
              'throw-handler-default
              %%default-error-handler)

;; A number of internally defined error types are represented
;; as integers.  Here is the mapping to symbolic names
;; and error messages.
;;
(define %%system-errors
  '((-1 UNKNOWN "Unknown error")
    (0 ARGn  "Wrong type argument to ")
    (1 ARG1  "Wrong type argument in position 1 to ")
    (2 ARG2  "Wrong type argument in position 2 to ")
    (3 ARG3  "Wrong type argument in position 3 to ")
    (4 ARG4  "Wrong type argument in position 4 to ")
    (5 ARG5  "Wrong type argument in position 5 to ")
    (6 ARG5  "Wrong type argument in position 5 to ")
    (7 ARG5  "Wrong type argument in position 5 to ")
    (8 WNA "Wrong number of arguments to ")
    (9 OVFLOW "Numerical overflow to ")
    (10 OUTOFRANGE "Argument out of range to ")
    (11 NALLOC "Could not allocate to ")
    (12 EXIT "Exit (internal error?).")
    (13 HUP_SIGNAL "hang-up")
    (14 INT_SIGNAL "user interrupt")
    (15 FPE_SIGNAL "arithmetic error")
    (16 BUS_SIGNAL "bus error")
    (17 SEGV_SIGNAL "segmentation violation")
    (18 ALRM_SIGNAL "alarm")))

;; The default handler for built-in error types when
;; thrown by their symbolic name.
;;
(define (%%handle-system-error ignored desc proc . args)
  (let* ((b (assoc desc %%system-errors))
     (msghead (cond
           (b (caddr b))
           ((or (symbol? desc) (string? desc))
            (string-append desc " "))
           (#t "Unknown error")))
     (msg (if (symbol? proc)
          (string-append msghead proc ":")
          msghead))
     (rest (if (and proc (not (symbol? proc)))
           (cons proc args)
           args))
     (fixed-args (cons msg rest)))
    (apply error fixed-args)))

;; Install default handlers for built-in errors.
;;
(map (lambda (err)
       (set-symbol-property! (cadr err)
                 'throw-handler-default
                 %%handle-system-error))
     (cdr %%system-errors))


;; All system errors are thrown as %%system-error.  Here
;; is the default handler that rethrows a more specific
;; error.
;;
(define (%%generic-system-error-handler ignored desc . args)
  (let ((key (assoc desc %%system-errors)))
    (if key
    (apply throw (cadr key) desc args)
    (apply throw 'UNKNOWN desc args))))

(set-symbol-property! '%%system-error
              'throw-handler-default
              %%handle-system-error)





;;; {Misc.}
;;;

(define slib:exit quit)
(define exit quit)


(define (terms)
  (list-file (in-vicinity (implementation-vicinity) "COPYING")))

(define (list-file file)
  (call-with-input-file file
    (lambda (inport)
      (do ((c (read-char inport) (read-char inport)))
      ((eof-object? c))
    (write-char c)))))

(define (file-exists? str)
  (let ((port (open-file str OPEN_READ)))
    (if port (begin (close-port port) #t)
    #f)))

(define set-errno errno)


(define difftime -)
(define offset-time +)

(if (not (memq 'ed *features*))
    (begin
      (define (ed . args)
    (system (apply string-append
               (or (getenv "EDITOR") "ed")
               (map (lambda (s) (string-append " " s)) args))))
      (set! *features* (cons 'ed *features*))))

(define (has-suffix? str suffix)
  (let ((sufl (string-length suffix))
    (sl (string-length str)))
    (and (> sl sufl)
     (string=? (substring str (- sl sufl) sl) suffix))))


(define slib:error error)
(define slib:tab #\tab)
(define slib:form-feed #\page)
(define slib:eval eval)


;;; {List Comparison}
;;;

;; Compare two lists, describing insertions/deletions needed
;; to change one to the other.
;;
(define (diff-lists a b cmp?)
  (let* ((a-len (length a))
     (b-len (length b))
     (memo (make-array #f (+ a-len 1) (+ 1 b-len)))
     (cost (compute-cost! a a-len b b-len memo cmp?))
     (cost-at (lambda (x y) (array-ref memo x y))))
    (letrec ((findpath (lambda (aa a-pos bb b-pos)
             (cond
              ((eq? a-pos 0) (map (lambda (e) `(+ ,e)) bb))
              ((eq? b-pos 0) (map (lambda (e) `(- ,e)) aa))
              ((cmp? (car aa) (car bb))
               `((.. ,(car aa))
                 ,@(findpath (cdr aa) (+ -1 a-pos)
                     (cdr bb) (+ -1 b-pos))))
              ((eq? (+ -1 (cost-at a-pos b-pos))
                (cost-at (+ -1 a-pos) b-pos))
               `((- ,(car aa))
                 ,@(findpath (cdr aa) (+ -1 a-pos) bb b-pos)))
              (else
               `((+ ,(car bb))
                 ,@(findpath aa a-pos (cdr bb) (+ -1 b-pos))))))))
      (findpath a a-len b b-len))))


;; Compute the number of insertions/deletions needed to change
;; one list into another.  The memo is a 2d array of at least
;; a-len X b-len elements.  The memo is used to speed up computing
;; the cost, but really the side effects on the array are interesting
;; output.  Tracing the table later is how a specific sequence
;; of ins/del is computed.
;;

(define (compute-cost! a a-len b b-len memo cmp?)
  (let ((answer
     (cond
      ((eq? 0 b-len) a-len)

      ((eq? 0 a-len) b-len)

      ((array-ref memo a-len b-len)
       (array-ref memo a-len b-len))

      ((cmp? (car a) (car b))
       (compute-cost! (cdr a) (+ -1 a-len)
              (cdr b) (+ -1 b-len)
              memo cmp?))

      (else
       (let ((first-way (compute-cost! (cdr a) (+ -1 a-len)
                       b b-len
                       memo cmp?))
         (second-way (compute-cost! a a-len
                        (cdr b) (+ -1 b-len)
                        memo cmp?)))
         (+ 1 (min first-way second-way)))))))

    (array-set! memo answer a-len b-len)
    answer))



;;; {File Systems}
;;;



;;; {Load}
;;;

(define load:indent 0)

(define (scm:load file . libs)
  (define sfs (scheme-file-suffix))
  (define cep (current-error-port))
  (cond ((> (verbose) 1)
      (display
       (string-append ";" (make-string load:indent #\ ) "loading " file)
       cep)
      (set! load:indent (modulo (+ 2 load:indent) 16))
      (newline cep)))
  (force-output cep)
  (let ((floaded
     (or (and (defined? link:link) (not hss)
          (or (and (apply link:link file libs) file)
              (and link:able-suffix
               (let ((fs (string-append file link:able-suffix)))
                 (cond ((not (file-exists? fs)) #f)
                   ((apply link:link fs libs) fs)
                   (else #f))))))
         (and (try-load file) file)
         (let ((fs (string-append file sfs)))
           (and (try-load fs) fs))
         (let ((fs (in-vicinity (library-vicinity) file)))
           (and (try-load fs) fs))
         (let ((fs (string-append (in-vicinity (library-vicinity) file) sfs)))
           (and (try-load fs) fs))
         (begin
           (set! load:indent 0)
           (error "LOAD couldn't find file " file)))))
    (errno 0)
    (cond ((> (verbose) 1)
       (set! load:indent (modulo (+ -2 load:indent) 16))
       (display (string-append ";" (make-string load:indent #\ )
                   "done loading " floaded)
            cep)
       (newline cep)
       (force-output cep)))))

(define (scm:load-source file)
  (define sfs (scheme-file-suffix))
  (define cep (current-error-port))
  (cond ((> (verbose) 1)
     (display ";loading " cep) (write file cep) (newline cep)))
  (force-output cep)
  (let ((name-loaded
     (or  (try-load file)
          (let ((fs (string-append file sfs)))
        (and (try-load fs) fs))
          (let ((fs (in-vicinity (library-vicinity) file)))
        (and (try-load fs) fs))
          (let ((fs (string-append (in-vicinity (library-vicinity) file) sfs)))
        (and (try-load fs) fs))
          (error "LOAD couldn't find file " file))))
    (errno 0)
    (cond ((> (verbose) 1)
       (display ";done loading " cep) (write name-loaded cep) (newline cep)
       (force-output cep)))))


;; library-vicinity should return the pathname of the
;; directory where files of Scheme library functions reside.
;;
(define library-vicinity
  (let ((library-path
     (or (getenv "SCHEME_LIBRARY_PATH")
         (case (software-type)
           ((UNIX COHERENT) (or (and (defined? compiled-library-path)
                     (compiled-library-path))
                    "/usr/local/lib/slib/"))
           ((VMS) "lib$scheme:")
           ((MS-DOS WINDOWS ATARIST) "C:\\SCM\\SLIB\\")
           ((OS/2) "\\languages\\scm\\slib\\")
           ((MACOS THINKC) "camus Napoleon:Think C4.0:scm3.0:")
           ((AMIGA) "Scheme:libs/")
           (else "")))))

    (lambda () library-path)))

;; program-vicinity is here in case the Scheme Library cannot be found.
;;

(define program-vicinity
  (let ((*vicinity-suffix*
     (case (software-type)
       ((UNIX COHERENT) '(#\/))
       ((AMIGA) '(#\: #\/))
       ((VMS) '(#\: #\]))
       ((MS-DOS WINDOWS ATARIST OS/2) '(#\\))
       ((MACOS THINKC) '(#\:)))))
    (lambda ()
      (let loop ((i (- (string-length *load-pathname*) 1)))
    (cond ((negative? i) "")
          ((memv (string-ref *load-pathname* i)
             *vicinity-suffix*)
           (substring *load-pathname* 0 (+ i 1)))
          (else (loop (- i 1))))))))

;;; Here for backward compatability
;;
(define scheme-file-suffix
  (case (software-type)
    ((NOSVE) (lambda () "_scm"))
    (else (lambda () ".scm"))))

(define in-vicinity string-append)

;;; This is the vicinity where this file resides.
(define implementation-vicinity
  (let ((vic (program-vicinity)))
    (lambda () vic)))


(define load scm:load)
(define slib:load load)
(define slib:load-source scm:load-source)

(cond ((try-load
    (in-vicinity (library-vicinity) "require" (scheme-file-suffix))))
      (else
       (perror "WARNING")
       (display "WARNING: Couldn't find require.scm in (library-vicinity)"
        (current-error-port))
       (write (library-vicinity) (current-error-port))
       (newline (current-error-port))
       (errno 0)))


;;; DO NOT MOVE!  This has to be done after "require.scm" is loaded.
(define slib:load-source scm:load-source)
(define slib:load scm:load)



;;; {Autoloads for SLIB Procedures}
;;;

(define (tracef . args) (require 'trace) (apply tracef args))
(define (trace:tracef . args) (require 'trace) (apply trace:tracef args))
(define (pretty-print . args) (require 'pretty-print)
  (apply pretty-print args))
(define (pp . args) (apply pretty-print args))
(define (pk key val) (pp (list key val)) val)
(define (print . args) (require 'debug) (apply print args))



(define (predicate->hash pred)
  (cond ((eq? pred eq?) hashq)
    ((eq? pred eqv?) hashv)
    ((eq? pred equal?) hash)
    ((eq? pred =) hashv)
    ((eq? pred char=?) hashv)
    ((eq? pred char-ci=?) hashv)
    ((eq? pred string=?) hash)
    ((eq? pred string-ci=?) hash)
    (else (slib:error "unknown predicate for hash" pred))))

(define (make-hash-table k) (make-vector k '()))

(define (predicate->hash-asso pred)
  (let ((hashfun (predicate->hash pred))
    (asso (predicate->asso pred)))
    (lambda (key hashtab)
      (asso key
        (vector-ref hashtab (hashfun key (vector-length hashtab)))))))

(define (hash-inquirer pred)
  (let ((hashfun (predicate->hash pred))
    (ainq (alist-inquirer pred)))
    (lambda (hashtab key)
      (ainq (vector-ref hashtab (hashfun key (vector-length hashtab)))
        key))))

(define (hash-associator pred)
  (let ((hashfun (predicate->hash pred))
    (asso (alist-associator pred)))
    (lambda (hashtab key val)
      (let* ((num (hashfun key (vector-length hashtab))))
    (vector-set! hashtab num
             (asso (vector-ref hashtab num) key val)))
      hashtab)))

(define (hash-remover pred)
  (let ((hashfun (predicate->hash pred))
    (arem (alist-remover pred)))
    (lambda (hashtab key)
      (let* ((num (hashfun key (vector-length hashtab))))
    (vector-set! hashtab num
             (arem (vector-ref hashtab num) key)))
      hashtab)))

(define (hash-map proc ht)
  (define nht (make-vector (vector-length ht)))
  (do ((i (+ -1 (vector-length ht)) (+ -1 i)))
      ((negative? i) nht)
    (vector-set!
     nht i
     (alist-map proc (vector-ref ht i)))))

(define (hash-for-each proc ht)
  (do ((i (+ -1 (vector-length ht)) (+ -1 i)))
      ((negative? i))
    (alist-for-each proc (vector-ref ht i))))



(define (predicate->asso pred)
  (cond ((eq? eq? pred) assq)
    ((eq? = pred) assv)
    ((eq? eqv? pred) assv)
    ((eq? char=? pred) assv)
    ((eq? equal? pred) assoc)
    ((eq? string=? pred) assoc)
    (else (lambda (key alist)
        (let l ((al alist))
          (cond ((null? al) #f)
            ((pred key (caar al)) (car al))
            (else (l (cdr al)))))))))

(define (alist-inquirer pred)
  (let ((assofun (predicate->asso pred)))
    (lambda (alist key)
      (let ((pair (assofun key alist)))
    (and pair (cdr pair))))))

(define (alist-associator pred)
  (let ((assofun (predicate->asso pred)))
    (lambda (alist key val)
      (let* ((pair (assofun key alist)))
    (cond (pair (set-cdr! pair val)
            alist)
          (else (cons (cons key val) alist)))))))

(define (alist-remover pred)
  (lambda (alist key)
    (cond ((null? alist) alist)
      ((pred key (caar alist)) (cdr alist))
      ((null? (cdr alist)) alist)
      ((pred key (caadr alist))
       (set-cdr! alist (cddr alist)) alist)
      (else
       (let l ((al (cdr alist)))
         (cond ((null? (cdr al)) alist)
           ((pred key (caadr al))
            (set-cdr! al (cddr al)) alist)
           (else (l (cdr al)))))))))

(define (alist-map proc alist)
  (map (lambda (pair) (cons (car pair) (proc (car pair) (cdr pair))))
       alist))

(define (alist-for-each proc alist)
  (for-each (lambda (pair) (proc (car pair) (cdr pair))) alist))


;;; {Dynamic Loading}
;;;

(if (or (defined? dld:link)
    (defined? shl:load)
    (defined? vms:dynamic-link-call)
    (file-exists? (in-vicinity (implementation-vicinity) "hobbit.tms")))
    (try-load (in-vicinity (implementation-vicinity)
               "Link" (scheme-file-suffix))))

(cond ((defined? link:link)
       (define slib:load-compiled link:link)
       (provide 'compiled)))

;;; {Macros}
;;;

;defmacro from [e-mail] (heavily hacked by jaffer):
(define *defmacros* '())
(define (defmacro? m) (and (assq m *defmacros*) #t))

(define defmacro:transformer
  (lambda (f)
    (procedure->memoizing-macro
      (lambda (exp env)
    (copy-tree (apply f (cdr exp)))))))

(define defmacro
  (let ((defmacro-transformer
      (lambda (name parms . body)
        (let ((transformer `(lambda ,parms ,@body)))
          `(define ,name
         (,(lambda (transformer)
             (set! *defmacros* (acons name transformer *defmacros*))
             (defmacro:transformer transformer))
          ,transformer))))))
    (set! *defmacros* (acons 'defmacro defmacro-transformer *defmacros*))
    (defmacro:transformer defmacro-transformer)))

(define (macroexpand-1 e)
  (if (pair? e) (let ((a (car e)))
          (cond ((symbol? a) (set! a (assq a *defmacros*))
                     (if a (apply (cdr a) (cdr e)) e))
            (else e)))
      e))

(define (macroexpand e)
  (if (pair? e) (let ((a (car e)))
          (cond ((symbol? a)
             (set! a (assq a *defmacros*))
             (if a (macroexpand (apply (cdr a) (cdr e))) e))
            (else e)))
      e))

(define gentemp
  (let ((*gensym-counter* -1))
    (lambda ()
      (set! *gensym-counter* (+ *gensym-counter* 1))
      (string->symbol
       (string-append "scm:G" (number->string *gensym-counter*))))))

(define defmacro:eval slib:eval)
(define defmacro:load load)

(define (slib:eval-load <filename> evl)
  (if (not (file-exists? <filename>))
      (set! <filename> (string-append <filename> (scheme-file-suffix))))
  (call-with-input-file <filename>
    (lambda (port)
      (let ((old-load-pathname *load-pathname*))
    (set! *load-pathname* <filename>)
    (do ((o (read port) (read port)))
        ((eof-object? o))
      (evl o))
    (set! *load-pathname* old-load-pathname)))))


;;; {Some Handy Macros}
;;;

;;; Trace gets redefmacroed when tracef autoloads.
(defmacro trace x
  (if (null? x) '()
      `(begin ,@(map (lambda (x) `(set! ,x (trace:tracef ,x ',x))) x))))

(defmacro defvar (var val)
  `(if (not (defined? ,var)) (define ,var ,val)))


;;; {Transcendental Functions}
;;;

(cond ((and (inexact? (string->number "0.0")) (not (defined? exp)))
       (if (defined? usr:lib)
       (load (in-vicinity (library-vicinity) "Transcen")
         (usr:lib "m"))
       (load (in-vicinity (library-vicinity) "Transcen"
                  (scheme-file-suffix))))
       (set! abs magnitude)))


;;; {These are missing from the C code.}
;;;

(define (symbol-append . args)
  (string->symbol (apply string-append args)))

(define (obarray-symbol-append ob . args)
  (string->obarray-symbol (apply string-append args)))

(define make-kw make-keyword)
(define (symbol->keyword symbol)
  (make-keyword (symbol-append '- symbol)))
(define (keyword->symbol kw)
  (let ((sym (keyword-symbol kw)))
    (string->symbol (substring sym 1 (length sym)))))

(define (kw-arg-ref args kw)
  (let ((rem (member kw args)))
    (and rem (pair? (cdr rem)) (cadr rem))))

(define (list-index l k)
  (let loop ((n 0)
         (l l))
    (and (not (null? l))
     (if (eq? (car l) k)
         n
         (loop (+ n 1) (cdr l))))))

(define (make-list n init)
  (let loop ((answer '())
         (n n))
    (if (<= n 0)
    answer
    (loop (cons init (answer)) (- n 1)))))



;;; {Arrays}
;;;

(if (defined? array?)
    (begin
      (define uniform-vector? array?)
      (define make-uniform-vector dimensions->uniform-array)
;      (define uniform-vector-ref array-ref)
      (define (uniform-vector-set! u i o)
    (uniform-vector-set1! u o i))
      (define uniform-vector-fill! array-fill!)
      (define uniform-vector-read! uniform-array-read!)
      (define uniform-vector-write uniform-array-write)

      (define (make-array fill . args)
    (dimensions->uniform-array args () fill))
      (define (make-uniform-array prot . args)
    (dimensions->uniform-array args prot))
      (define (list->array ndim lst)
    (list->uniform-array ndim '() lst))
      (define (list->uniform-vector prot lst)
    (list->uniform-array 1 prot lst))
      (define (array-shape a)
    (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
         (array-dimensions a)))))


;;; {Lvectors}
;;;

;; These are the offsets of hook functions within a type lvector.
;; They must agree with declarations in scm.h (bleah)
;;
(define lvector-hook-ref-fn 1)
(define lvector-hook-set-fn 2)
(define lvector-hook-print-fn 3)
(define lvector-hook-equal-fn 4)
(define lvector-hook-isa-fn 5)

(define lvector-hook-slots 6)


;; names that will go away eventually...
;;
(define lvector_hook_ref_fn lvector-hook-ref-fn)
(define lvector_hook_set_fn lvector-hook-set-fn)
(define lvector_hook_print_fn lvector-hook-print-fn)
(define lvector_hook_equal_fn lvector-hook-equal-fn)
(define lvector_hook_isa_fn lvector-hook-isa-fn)
(define lvector_hook_slots lvector-hook-slots)

;;; {The Module System}
;;;

(load (in-vicinity (library-vicinity) "Gmodules.scm"))


;;; {Running Repls}
;;;


;; Mystery integer passed to error handlers:
;;
(define repl-quit -1)
(define repl-abort -2)
(define on-a-new-stack #f)

(define (verbose-repl verbosity prompt env)
  (let ((old-v (verbose)))
    (dynamic-wind
     (lambda () (set! old-v (verbose verbosity)))
     (lambda () (repl prompt env))
     (lambda () (set! verbosity (verbose old-v))))))

(define guile-prompt "guile> ")
(define (guile-repl-thunk)
  (verbose-repl (%default-verbosity) guile-prompt #f))

(define %%repl-thunk guile-repl-thunk)

(define rooted-repl
  (lambda (inp)
    (with-dynamic-root
     (lambda ()
       (let ((new-stack-req
          (call-with-current-continuation
           (lambda (cc)
         (set! on-a-new-stack
               (lambda (thunk)
             (call-with-current-continuation
              (lambda (cc2) (cc (cons thunk cc2))))))
         (with-input-from-port inp
           (lambda () (%%repl-thunk)))))))
     ((cdr new-stack-req) ((car new-stack-req)))))
     (lambda (errcode)
       (with-input-from-port inp
     (lambda ()
       (cond
        ((= errcode repl-quit) #t)
        (#t (%%repl-thunk)))))))))

(define stand-alone-repl
  (let ((stdin *stdin*))
    (lambda () (rooted-repl stdin))))


(define (synthetic-repl prompt read eval print port)
  (let ((repl (lambda ()
        (let loop ((form (begin (prompt) (read))))
          (print (eval form))
          (loop (begin (prompt) (read)))))))
    (with-dynamic-root
     (lambda () (with-input-from-port port repl))
     (lambda (errcode)
       (with-input-from-port port
     (lambda ()
       (cond
        ((= errcode repl-quit) #t)
        (#t (repl)))))))))



;;; {Pleasant Wrappers for System Calls}
;;;
;; (load (in-vicinity (library-vicinity) "Gsystem.scm"))

;;;  {Shorthand for small equal?-based Hash Tables}
;;;

(define aref (hash-inquirer equal?))
(define aremove (hash-remover equal?))
(define aset! (hash-associator equal?))
(define (make-table) (make-hash-table 64))



;;; {Parsing and Acting on the Command Line}
;;;

;;; Use *argv* instead of (program-arguments), to allow option
;;; processing to be done on it.
(define *argv* (program-arguments))

;;; This loads the user's initialization file, or files named in
;;; program arguments.

(define (top-level-once thunk)
  (let ((didit #f))
    (catch #t
     (lambda ()
       (thunk)
       (if didit
       (error 'once-was-enough))
       (set! didit #t))
     (lambda err
       (if didit
       (error 'once-was-enough--error))
       (set! didit #t)
       (write (cons 'ERROR err) (current-error-port))
       (newline (current-error-port))
       #f))))


(define built-in-variable builtin-variable)

(top-level-once
 (lambda ()
   (or
    (eq? (software-type) 'THINKC)
    (member "-no-init-file" (program-arguments))
    (try-load
     (in-vicinity
      (let ((home (getenv "HOME")))
    (cond
     (home (case (software-type)
         ((UNIX COHERENT)
          (if (char=? #\/ (string-ref home (+ -1 (string-length home))))
              home            ;V7 unix has a / on HOME
              (string-append home "/")))
         (else home)))

     ((and (defined? getpw) (defined? geteuid) (getpw (geteuid)))
      (vector-ref (getpw (geteuid)) 5))

     ((defined? user-vicinity) (user-vicinity))

     (t "/")))
      "ScmInit.scm"))
    (errno 0))))

(if (not (defined? *R4RS-macro*))
    (define *R4RS-macro* #f))

(if (not (defined? *interactive*))
    (define *interactive* #f))

(if (not (defined? 'type))
    (define type #f))

(top-level-once
 (lambda ()
   (cond
    ((and (> (length *argv*) 1) (char=? #\- (string-ref (cadr *argv*) 0)))
     (load (in-vicinity (library-vicinity) "getopt"))
;;; (else
;;;  (define *optind* 1)
;;;  (define getopt:opt #f)
;;;  (define (getopt argc argv optstring) #f))

     (let* ((simple-opts "muqvbis")
        (arg-opts '("a kbytes" "no-init-file" "p number"
                   "r feature" "f filename" "l filename"
                   "c string" "e string"))
        (opts (apply string-append ":" simple-opts
             (map (lambda (o)
                (string-append (string (string-ref o 0)) ":"))
                  arg-opts)))
        (argc (length *argv*))
        (didsomething #f)
        (moreopts #t))

       (define (do-thunk thunk)
     (if *interactive*
         (thunk)
         (let ((complete #f))
           (with-dynamic-root
        (lambda ()
          (thunk)
          (set! complete #t))
        (lambda status
          ;; The thunk tried to escape its continuation in
          ;; an unusual way.  Give up.
          (quit))))))

       (define (do-string-arg)
     (require 'string-port)
     (do-thunk
      (lambda ()
        (eval
         (call-with-input-string
          (string-append "(begin " *optarg* ")")
          read))))
     (set! didsomething #t))

       (define (do-load file)
     (do-thunk
      (lambda ()
        (cond (*R4RS-macro* (require 'macro) (macro:load file))
          (else (load file)))))
     (set! didsomething #t))

       (define (usage preopt opt postopt)
     (define cep (current-error-port))
     (define indent (make-string 6 #\ ))
     (define i 3)
     (if (char? opt) (set! opt (string opt)))
     (display (string-append preopt opt postopt) cep)
     (newline cep)
     (display (string-append "Usage: " (car (program-arguments))
                 " [-a kbytes] [-" simple-opts "]") cep)
     (for-each
      (lambda (o)
        (display (string-append " [-" o "]") cep)
        (set! i (+ 1 i))
        (cond ((zero? (modulo i 4)) (newline cep) (display indent cep))))
      (cdr arg-opts))
     (display " [-- | -s | -] [file] [args...]" cep) (newline cep)
     (exit #f))

       ;; -a int => ignore (handled by run_scm)
       ;; -c str => (eval str)
       ;; -e str => (eval str)
       ;; -f str => (load str)
       ;; -l str => (load str)
       ;; -r str => (require str)
       ;; -p int => (verbose int)
       ;; -m     => (set! *R4RS-macro* #t)
       ;; -u     => (set! *R4RS-macro* #f)
       ;; -v     => (verbose 3)
       ;; -q     => (verbose 0)
       ;; -i     => (set! *interactive* #t)
       ;; -b     => (set! *interactive* #f)
       ;; -s     => set argv, don't execute first one
       ;; -no-init-file => don't load init file
       ;; --     => last option

       (let loop ()
     (case (getopt argc *argv* opts)
       ((#\a)
        (cond ((> *optind* 3)
           (usage "scm: option `-" getopt:opt "' must be first"))
          ((or (not (exact? (string->number *optarg*)))
               (not (<= 1 (string->number *optarg*) 10000)))
           ;;    This size limit should match scm.c ^^
           (usage "scm: option `-" getopt:opt
              (string-append *optarg* "' unreasonable")))))
       ((#\e #\c) (do-string-arg))    ;sh-like
       ((#\f #\l);;(set-car! *argv* *optarg*)
        (do-load *optarg*))
       ((#\r) (do-thunk (lambda ()
                  (if (and (= 1 (string-length *optarg*))
                       (char-numeric? (string-ref *optarg* 0)))
                  (case (string-ref *optarg* 0)
                    ((#\2) (require 'rev3-procedures)
                       (require 'rev2-procedures))
                    ((#\3) (require 'rev3-procedures))
                    ((#\4) (require 'rev4-optional-procedures))
                    ((#\5) (require 'dynamic-wind)
                       (require 'values)
                       (require 'macro)
                       (set! *R4RS-macro* #t))
                    (else (require (string->symbol *optarg*))))
                  (require (string->symbol *optarg*))))))
       ((#\p) (verbose (string->number *optarg*)))
       ((#\q) (verbose 0))
       ((#\v) (verbose 3))
       ((#\i) (set! *interactive* #t)    ;sh-like
          (verbose (max 2 (verbose))))
       ((#\b) (set! *interactive* #f))
       ((#\s) (set! moreopts #f)    ;sh-like
          (set! didsomething #t)
          (set! *interactive* #t))
       ((#\m) (set! *R4RS-macro* #t))
       ((#\u) (set! *R4RS-macro* #f))
       ((#\n) (if (not (string=? "o-init-file" *optarg*))
              (usage "scm: unrecognized option `-n" *optarg* "'")))
       ((#\:) (usage "scm: option `-" getopt:opt "' requires an argument"))
       ((#\?) (usage "scm: unrecognized option `-" getopt:opt "'"))
       ((#f) (set! moreopts #f)    ;sh-like
         (cond ((and (< *optind* (length *argv*))
                 (string=? "-" (list-ref *argv* *optind*)))
            (set! *optind* (+ 1 *optind*)))))
       (else (usage "scm: unknown option `-" getopt:opt "'")))

     (cond ((and moreopts (< *optind* (length *argv*)))
        (loop))
           ((< *optind* (length *argv*)) ;No more opts
        (set! *argv* (list-tail *argv* *optind*))
        (set! *optind* 1)
        (cond ((not didsomething) (do-load (car *argv*))
                      (set! *optind* (+ 1 *optind*))))
        (cond ((and (> (verbose) 2)
                (not (= (+ -1 *optind*) (length *argv*))))
               (display "scm: extra command arguments unused:"
                (current-error-port))
               (for-each (lambda (x) (display (string-append " " x)
                              (current-error-port)))
                 (list-tail *argv* (+ -1 *optind*)))
               (newline (current-error-port)))))
           ((and (not didsomething) (= *optind* (length *argv*)))
        (set! *interactive* #t)))))

     (cond ((not *interactive*) (quit))
       (*R4RS-macro*
        (require 'repl)
        (require 'macro)
        (let* ((oquit quit))
          (set! quit (lambda () (repl:quit)))
          (set! exit quit)
          (repl:top-level macro:eval)
          (oquit))))
     ;;otherwise, fall into non-macro SCM repl.
     )
    (else
     (begin (errno 0)
        (for-each load (cdr (program-arguments))))))))